home *** CD-ROM | disk | FTP | other *** search
/ TOS Silver 2000 / TOS Silver 2000.iso / programm / MM2_DEV / S / MOS / TIMECONV.I < prev    next >
Encoding:
Modula Implementation  |  1994-01-14  |  15.1 KB  |  585 lines
  1. IMPLEMENTATION MODULE TimeConvert; (* V#064 *)
  2. (*$R-*)
  3. (*$Y+*)
  4. FROM SYSTEM IMPORT ASSEMBLER;
  5.  
  6. (*
  7.   05.02.89: Frz. Monatsnamen gehen jetzt.
  8.   09.08.89: Optmierungen: FastStrings verwendet; TimeToText & Chr in Asm.
  9.   03.09.89: #U f. user-defined Monatsnamen; TextToDate läßt nun auch
  10.             nicht-dtsche Umlaute zu und es können Monate von -9999 bis
  11.             +9999 eingegeben werden - allerdings werden 80 bis 99 nach
  12.             1980 bis 1999 gewandelt!
  13.   30.06.90: TimeToText und TextToTime funktionieren jetzt immer korrekt,
  14.             d.h. TextToTime kann auch mit 100250 (10 Uhr 2min 50sec)
  15.             aufgerufen werden und TimeToText wertet jetzt die Maske
  16.             aus! Änderungen durch Dirk Steins (DS). Gekennzeichnte mit %%.
  17.   05.07.90: Änderungen von Dirk Steins korrigiert, TextTo-Funktionen setzen
  18.             valid nun auf FALSE, wenn nach der Zeit-/Datumsangabe der String
  19.             nicht endet.
  20.   10.11.90: TextToDate prüft nun auch den 31. bei den Monaten sowie Schaltjahre
  21.             (von D.Steins)
  22.   14.02.91: DateToText/Repl zerstört nicht mehr D3-D6
  23.   14.01.94: DateToText/TimeToText korrigiert (D.Steins)
  24. *)
  25.  
  26. FROM SYSTEM IMPORT WORD, ADR;
  27.  
  28. FROM Characters IMPORT IsAlpha;
  29.  
  30. FROM Clock IMPORT Time, Date;
  31.  
  32. FROM StrConv IMPORT CardToStr, NumToStr, StrToCard, StrToInt;
  33.  
  34. FROM Strings IMPORT Upper, StrEqual, String, Empty;
  35.  
  36. FROM FastStrings IMPORT Delete, Assign, Pos, Length, Copy, Chr;
  37.  
  38. IMPORT Strings;
  39.  
  40. FROM MOSGlobals IMPORT StringOverflow;
  41.  
  42. FROM MOSConfig IMPORT NameOfMonth, StdDateExp, StdDateMask, StdTimeMask;
  43.  
  44.  
  45. CONST langHigh = 2; (* höchster Sprachindex f. 'mon' *)
  46.       monHigh = 9;
  47.  
  48. TYPE MonStr= ARRAY [0..monHigh] OF CHAR;
  49.  
  50. VAR strok: BOOLEAN;
  51.  
  52. PROCEDURE Repl (VAR source: ARRAY OF CHAR; index,len:WORD; VAR dest:ARRAY OF CHAR );
  53. (*$L-*)
  54. BEGIN
  55.   ASSEMBLER
  56.         MOVEM.L D3-D6,-(A7)
  57.         MOVE    -(A3),D6         ;HIGH(dest)
  58.         MOVE.L  -(A3),A2         ;dest
  59.         MOVE    -(A3),D0         ;D0:=len
  60.         MOVE    -(A3),D1         ;D1:=index
  61.         MOVE    -(A3),D5         ;HIGH(source)
  62.         MOVE.L  -(A3),A1         ;source
  63.         MOVEQ   #0,D4           ; index f. dest
  64.         MOVEQ   #-1,D2          ; index f. source
  65.         TST     D0
  66.         BNE     start
  67.         
  68. l2      ADDQ    #1,D2
  69.         CMP     D1,D2           ; haben wir start-index erreicht ?
  70.         BEQ     ok
  71.         CMP     D5,D2
  72.         BHI     ende             ; Stringende überschritten
  73.         TST.B   0(A1,D2.W)
  74.         BEQ     ende
  75.         BRA     l2              ; Nein, noch nicht kopieren
  76.         
  77. l       ADDQ    #1,D2
  78.         CMP     D5,D2
  79.         BHI     ende             ; Stringende überschritten
  80.         MOVE.B  0(A1,D2.W),D3
  81.         BEQ     ende
  82.         CMP     D1,D2           ; haben wir start-index erreicht ?
  83.         BCS     l               ; Nein, noch nicht kopieren
  84.         CMP     D6,D4           ; paßt Zeichen noch in String ?
  85.         BHI     ende
  86.         MOVE.B  D3,0(A2,D4.W)   ; Zeichen kopieren
  87.         ADDQ    #1,D4
  88. start   DBRA    D0,l
  89. ok
  90. ende    MOVEM.L (A7)+,D3-D6
  91.   END
  92. END Repl;
  93. (*$L=*)
  94.  
  95.  
  96. PROCEDURE TimeToText ( s: Time; REF mask: ARRAY OF CHAR; VAR d: ARRAY OF CHAR );
  97. (*
  98.     IF HIGH (d) < 7 THEN
  99.       ASSEMBLER
  100.         TRAP    #6
  101.         DC.W    -8      ; string overflow
  102.       END
  103.     ELSE
  104.       WITH s DO
  105.         d[0]:=CHR(48 + hour DIV 10);
  106.         d[1]:=CHR(48 + hour MOD 10);
  107.         d[2]:=':';
  108.         d[3]:=CHR(48 + minute DIV 10);
  109.         d[4]:=CHR(48 + minute MOD 10);
  110.         d[5]:=':';
  111.         d[6]:=CHR(48 + second DIV 10);
  112.         d[7]:=CHR(48 + second MOD 10)
  113.       END;
  114.       IF HIGH (d) > 7 THEN
  115.         d[8]:= 0C
  116.       END
  117.     END
  118. *)
  119. (*
  120.     ASSEMBLER
  121.         MOVE.W  -(A3),D0
  122.         MOVE.L  -(A3),A0
  123.         MOVE.W  -(A3),D1
  124.         MOVE.L  -(A3),A1        ; mask
  125.         CMPI    #7,D0
  126.         BCC     ok
  127.         TRAP    #6
  128.         DC.W    StringOverflow
  129.         SUBQ.L  #6,A3
  130.         BRA     ende
  131.       ok
  132.         BEQ     ok2
  133.         CLR.B   8(A0)
  134.       ok2
  135.         MOVEQ   #48,D1
  136.         BSR     upro
  137.         MOVE.B  #':',(A0)+
  138.         BSR     upro
  139.         MOVE.B  #':',(A0)+
  140.         BSR     upro
  141.         BRA     ende
  142.       upro
  143.         MOVEQ   #0,D0
  144.         MOVE.W  -(A3),D0        ; Time.hour
  145.         DIVU    #10,D0
  146.         ADD.B   D1,D0
  147.         MOVE.B  D0,(A0)+
  148.         SWAP    D0
  149.         ADD.B   D1,D0
  150.         MOVE.B  D0,(A0)+
  151.         RTS
  152.       ende
  153.     END
  154. *)
  155.     (* %% Komplett neue PROCEDURE TimeToText. Wertet jetzt 'mask' komplett
  156.      * aus. Jeder Wert wird nur einmal in das Ergebnis gesetzt.
  157.      * Es wird kein Test auf ungültige Werte in 's' vorgenommen, sollten
  158.      * aber auch nicht drin sein.
  159.      *)
  160.     VAR english : BOOLEAN;
  161.         l       : CARDINAL;
  162.         p       : INTEGER;
  163.         i,j     : CARDINAL;
  164.         ch      : CHAR;
  165.         up, hSet, mSet, sSet, eSet: BOOLEAN;
  166.         
  167.   PROCEDURE set (value: CARDINAL; zeros: BOOLEAN);
  168.     VAR ins: String;
  169.     BEGIN
  170.       ins := NumToStr (value,10,2,'0');
  171.       IF zeros OR (ins[0] # '0') THEN
  172.         d[j] := ins[0];
  173.         INC(j);
  174.       END;
  175.       d[j] := ins[1];
  176.       INC(j);
  177.       INC(i, 2);
  178.     END set;
  179.  
  180.   PROCEDURE copy;
  181.     BEGIN
  182.       d[j] := mask[i];
  183.       INC(j);
  184.       INC(i);
  185.     END copy;
  186.   
  187.   BEGIN
  188.     IF Empty (mask) THEN
  189.       TimeToText (s, StdTimeMask, d);
  190.       RETURN
  191.     END;
  192.     (* Flags initialisieren *)
  193.     english := FALSE;
  194.     hSet := FALSE;
  195.     mSet := FALSE;
  196.     sSet := FALSE;
  197.     eSet := FALSE;
  198.     l := Length (mask);
  199.     IF l > (HIGH(d)+1) THEN
  200.       ASSEMBLER
  201.         TRAP    #6
  202.         DC.W    StringOverflow
  203.       END;
  204.       l:= HIGH (d)+1
  205.     END;
  206.     
  207.     (* Test auf englische Notierung: *)
  208.     p:= 0;
  209.     LOOP
  210.       p:= Strings.Pos ('#', mask, p);
  211.       IF p < 0 THEN EXIT END;
  212.       INC (p);
  213.       IF CAP (mask[p]) = 'E' THEN
  214.         english := TRUE;
  215.         EXIT
  216.       END
  217.     END;
  218.     
  219.     (* Maske scannen *)
  220.     j := 0;
  221.     i := 0;
  222.     WHILE i < l DO
  223.       ch:= mask[i];
  224.       IF (ch = '#') & (CAP(mask[i+1])='E') & ~eSet THEN
  225.         up:= mask[i+1]='E';
  226.         IF s.hour > 12 THEN
  227.           d[j] := 'p'
  228.         ELSE
  229.           d[j] := 'a'
  230.         END;
  231.         IF up THEN d[j]:= CAP (d[j]) END;
  232.         INC(j);
  233.         IF up THEN d[j]:= 'M' ELSE d[j]:= 'm' END;
  234.         INC(j);
  235.         INC(i,2);
  236.         eSet := TRUE;
  237.       ELSIF mask[i+1]=ch THEN
  238.         up:= ch = CAP (ch);
  239.         IF (CAP (ch) = 'H') & ~hSet THEN
  240.           IF english & (s.hour > 12) THEN
  241.             set (s.hour-12, up);
  242.           ELSE
  243.             set (s.hour, up)
  244.           END;
  245.           hSet:= TRUE
  246.         ELSIF (CAP (ch) = 'M') & ~mSet THEN
  247.           set (s.minute, up);
  248.           mSet:= TRUE
  249.         ELSIF (CAP (ch) = 'S') & ~sSet THEN
  250.           set (s.second, up);
  251.           sSet:= TRUE
  252.         ELSE
  253.           copy
  254.         END
  255.       ELSE
  256.         copy
  257.       END
  258.     END (* WHILE i *);
  259.     IF j <= HIGH (d) THEN
  260.       d[j] := 0c
  261.     END;
  262.   END TimeToText;
  263.  
  264.  
  265. PROCEDURE mon (lang: INTEGER; month: CARDINAL): MonStr;
  266.           (* lang: -1: User-defined, 0: Deutsch, 1:Frz., 2:Engl *)
  267.   (*$L-*)
  268.   BEGIN
  269.     ASSEMBLER
  270.         MOVE    -(A3),D0
  271.         SUBQ    #1,D0
  272.         MOVE    -(A3),D1
  273.         MOVE.L  A3,A0
  274.         ADDA.W  #monHigh+1,A3
  275.         BEQ     tger
  276.         BMI     tusr
  277.         SUBQ    #2,D1
  278.         BCS     tfrz
  279.  
  280.         LEA     eng(PC),A1
  281.         BRA     cont
  282.       tfrz:
  283.         LEA     frz(PC),A1
  284.         BRA     cont
  285.       tger:
  286.         LEA     ger(PC),A1
  287.         BRA     cont
  288.  
  289.       lup:
  290.         TST.B   (A1)+
  291.         BNE     lup
  292.       cont:
  293.         DBRA    D0,lup
  294.       lup2:
  295.         MOVE.B  (A1)+,(A0)+
  296.         BNE     lup2
  297.         RTS
  298.  
  299.       tusr:
  300.         LEA     NameOfMonth,A1
  301.         MULU    #10,D0          ; SIZE (NameOfMonth[1])
  302.         ADDA.W  D0,A1
  303.         MOVEQ   #monHigh,D1
  304.       lupu:
  305.         MOVE.B  (A1)+,(A0)+
  306.         DBEQ    D1,lupu
  307.         RTS
  308.  
  309.       ger:
  310.         ACZ     'Januar'
  311.         ACZ     'Februar'
  312.         ACZ     'März'
  313.         ACZ     'April'
  314.         ACZ     'Mai'
  315.         ACZ     'Juni'
  316.         ACZ     'Juli'
  317.         ACZ     'August'
  318.         ACZ     'September'
  319.         ACZ     'Oktober'
  320.         ACZ     'November'
  321.         ACZ     'Dezember'
  322.         
  323.       frz:
  324.         ACZ     'Janvier'
  325.         ACZ     'Février'
  326.         ACZ     'Mars'
  327.         ACZ     'Avril'
  328.         ACZ     'Mai'
  329.         ACZ     'Juin'
  330.         ACZ     'Juillet'
  331.         ACZ     'Août'
  332.         ACZ     'Septembre'
  333.         ACZ     'Octobre'
  334.         ACZ     'Novembre'
  335.         ACZ     'Décembre'
  336.         
  337.       eng:
  338.         ACZ     'January'
  339.         ACZ     'February'
  340.         ACZ     'March'
  341.         ACZ     'April'
  342.         ACZ     'May'
  343.         ACZ     'June'
  344.         ACZ     'July'
  345.         ACZ     'August'
  346.         ACZ     'September'
  347.         ACZ     'October'
  348.         ACZ     'November'
  349.         ACZ     'December'
  350.     END
  351.   END mon;
  352.   (*$L=*)
  353.  
  354. PROCEDURE DateToText ( s: Date; REF m0: ARRAY OF CHAR; VAR d: ARRAY OF CHAR );
  355.  
  356.   VAR mask: String;
  357.  
  358.   PROCEDURE Del (a,b:INTEGER);
  359.     BEGIN
  360.       Delete (d,a,b);
  361.       Delete (mask,a,b)
  362.     END Del;
  363.  
  364.   PROCEDURE set (ch:CHAR; v: CARDINAL): BOOLEAN;
  365.     VAR p,l,n:CARDINAL; ps: POINTER TO String; s2:String; c1,c2: CHAR; ok: BOOLEAN;
  366.     BEGIN
  367.       ok:= Pos (ch,d)>=0;
  368.       IF ok THEN
  369.         p:= Pos (ch,d);
  370.         n:=1;
  371.         WHILE Chr (d,p+n) = ch DO
  372.           INC (n)
  373.         END;
  374.         IF (Chr(d,p+n)='#') & (Chr(mask,p+n+1)='E') THEN
  375.           IF v=1 THEN c1:='s'; c2:='t'
  376.           ELSIF v=2 THEN c1:='n'; c2:='d'
  377.           ELSIF v=3 THEN c1:='r'; c2:='d'
  378.           ELSE c1:='t'; c2:='h' END;
  379.           d[p+n]:=c1; d[p+n+1]:=c2
  380.         END;
  381.         s2:= CardToStr (v,0);
  382.         l:= Length (s2);
  383.         IF l >= n THEN
  384.           (* Feld wird vollst. gefüllt; die Zahl rechtsbündig kopieren: *)
  385.           ps:= ADR (d)+LONG(p);
  386.           Repl (s2,l-n,n,ps^)
  387.         ELSE
  388.           IF mask[p] >= 'a' THEN
  389.             (* Feld ist zu groß; kürzen: *)
  390.             Del (p,n-l);
  391.             ps:= ADR (d)+LONG(p);
  392.             Repl (s2,0,l,ps^);
  393.           ELSE
  394.             (* Feld ist zu groß; mit Nullen füllen: *)
  395.             WHILE l # n DO
  396.               d[p]:='0';
  397.               INC (p);
  398.               DEC (n)
  399.             END;
  400.             ps:= ADR (d)+LONG(p);
  401.             Repl (s2,0,l,ps^)
  402.           END
  403.         END
  404.       END;
  405.       RETURN ok
  406.     END set;
  407.  
  408.   PROCEDURE monset (ch:CHAR; v: INTEGER);
  409.     VAR p,l,n:CARDINAL; ps: POINTER TO String; s2: MonStr;
  410.     BEGIN
  411.       IF Pos (ch,d)>=0 THEN
  412.         p:= Pos (ch,d);
  413.         n:=1;
  414.         WHILE Chr (d,p+n) = ch DO
  415.           INC (n)
  416.         END;
  417.         s2:= mon(v,s.month);
  418.         l:= Length (s2);
  419.         IF l >= n THEN
  420.           (* Feld wird vollst. gefüllt; den String linksbündig kopieren: *)
  421.           l:=n;
  422.         ELSE
  423.           (* Feld ist zu groß; kürzen: *)
  424.           Del (p,n-l)
  425.         END;
  426.         ps:= ADR (d)+LONG(p);
  427.         Repl (s2,0,l,ps^)
  428.       END
  429.     END monset;
  430.   
  431.   VAR ok: BOOLEAN;
  432.   
  433.   BEGIN
  434.     IF m0[0]=0C THEN
  435.       Assign (StdDateMask,mask)
  436.     ELSE
  437.       Assign (m0,mask)
  438.     END;
  439.     IF HIGH (d)+1 < Length (mask) THEN
  440.       ASSEMBLER
  441.         TRAP    #6
  442.         DC.W    -8      ; string overflow
  443.       END
  444.     ELSE
  445.       Assign (mask,d);
  446.       IF ~set ('D',s.day) THEN ok:= set ('d',s.day) END;
  447.       IF ~set ('M',s.month) THEN ok:= set ('m',s.month) END;
  448.       IF ~set ('Y',s.year) THEN ok:= set ('y',s.year) END;
  449.       monset ('U',-1);
  450.       monset ('G',0);
  451.       monset ('F',1);
  452.       monset ('E',2);
  453.     END
  454.   END DateToText;
  455.  
  456. PROCEDURE skip (VAR s:ARRAY OF CHAR; VAR p:CARDINAL);
  457.   BEGIN
  458.     WHILE (p<Length(s)) & ( (s[p]<'0') OR ((s[p]>'9') & (s[p]<'@')) ) DO
  459.       INC (p)
  460.     END;
  461.   END skip;
  462.  
  463. PROCEDURE get (VAR s: ARRAY OF CHAR; VAR p: CARDINAL;
  464.                VAR valid: BOOLEAN; required: BOOLEAN;
  465.                n: CARDINAL; low,hi:INTEGER; VAR i: WORD);
  466.   VAR p2:CARDINAL; str: ARRAY [0..3] OF CHAR; v: BOOLEAN;
  467.   BEGIN
  468.     (* maximal n Ziffern auswerten *)
  469.     Copy (s,p,n,str);
  470.     p2:= 0;
  471.     i:= WORD (StrToInt (str, p2, v));
  472.     INC (p, p2);
  473.     skip (s,p);
  474.     IF v THEN
  475.       IF (INTEGER(i)<low) OR (INTEGER(i)>hi) THEN i:= WORD(0); valid:=FALSE END
  476.     ELSE
  477.       i:= WORD(0);
  478.       IF required THEN valid:= FALSE END
  479.     END;
  480.   END get;
  481.  
  482. PROCEDURE TextToTime ( s: ARRAY OF CHAR; VAR d: Time; VAR valid: BOOLEAN );
  483.   
  484.   VAR p: CARDINAL; v: BOOLEAN;
  485.   
  486.   BEGIN
  487.     p:=0;
  488.     valid:=TRUE;
  489.     (* führende Blanks überspringen *)
  490.     WHILE s[p]=' ' DO INC (p) END;
  491.     get (s,p,valid,TRUE,2,0,23,d.hour);
  492.     get (s,p,valid,FALSE,2,0,59,d.minute);
  493.     get (s,p,valid,FALSE,2,0,59,d.second);
  494.     (* prüfen: Nach der Zeitangabe muß der String zu Ende sein *)
  495.     IF p < Length (s) THEN valid:= FALSE END
  496.   END TextToTime;
  497.  
  498. (*
  499.    1: d-m-y
  500.    2: m-d-y
  501.    3: y-m-d
  502.    4: y-d-m
  503. *)
  504.  
  505. PROCEDURE TextToDate ( s: ARRAY OF CHAR; exp: CARDINAL; VAR d: Date; VAR valid: BOOLEAN );
  506.   VAR p:CARDINAL;
  507.   PROCEDURE getd;
  508.     BEGIN
  509.       IF valid THEN
  510.         get (s,p,valid,TRUE,2,1,31,d.day)
  511.       END
  512.     END getd;
  513.   PROCEDURE getm;
  514.     VAR n,m:CARDINAL; lang: INTEGER; m1,m2: MonStr;
  515.     BEGIN
  516.       IF valid THEN
  517.         WHILE Chr(s,p)=' ' DO INC (p) END;
  518.         n:=0;
  519.         WHILE IsAlpha (Chr (s,p+n)) DO INC (n) END;
  520.         IF n>0 THEN
  521.           Copy (s,p,n,m1);
  522.           FOR m:=1 TO 12 DO
  523.             FOR lang:=-1 TO langHigh DO
  524.               Strings.Copy (mon(lang,m),0,n,m2,strok);
  525.               Upper (m2);
  526.               IF StrEqual (m2,m1) THEN
  527.                 d.month:=m;
  528.                 INC (p,n); skip (s,p);
  529.                 RETURN
  530.               END
  531.             END
  532.           END;
  533.           valid:= FALSE
  534.         ELSE
  535.           get (s,p,valid,TRUE,2,1,12,d.month)
  536.         END
  537.       END
  538.     END getm;
  539.   PROCEDURE gety;
  540.     BEGIN
  541.       IF valid THEN
  542.         get (s,p,valid,TRUE,4,-30000,30000,d.year);
  543.         IF valid THEN
  544.           IF (d.year>=80) & (d.year<=99) THEN INC (d.year,1900) END
  545.         END
  546.       END
  547.     END gety;
  548.   BEGIN
  549.     IF (exp=0) OR (exp>4) THEN exp:= StdDateExp END;
  550.     valid:=TRUE;
  551.     Upper (s);
  552.     p:=0;
  553.     (* führende Blanks überspringen *)
  554.     WHILE s[p]=' ' DO INC (p) END;
  555.     CASE exp OF
  556.       1: getd; getm; gety|
  557.       2: getm; getd; gety|
  558.       3: gety; getm; getd|
  559.       4: gety; getd; getm|
  560.     END;
  561.     (* Numerisch gültig, jetzt logische Prüfung
  562.      (Jedes 4. Jahr, außer es ist ein Jahrhundert und nicht ein Jahrvierhundert)
  563.     *)
  564.     IF valid THEN
  565.       (* prüfen: Nach der Zeitangabe muß der String zu Ende sein *)
  566.       WITH d DO
  567.         IF p < Length (s) THEN
  568.           valid:= FALSE
  569.         ELSIF (day > 30) & ((month = 2) OR (month = 4) OR (month = 6) OR
  570.             (month = 9) OR (month = 11)) THEN
  571.            valid := FALSE;
  572.         ELSIF (day > 29) & (month = 2) THEN
  573.           valid := FALSE;
  574.         ELSIF (day = 29) & (month = 2) THEN
  575.           IF ~((year MOD 4 = 0) &
  576.               ((year MOD 100 <> 0) OR (year MOD 400 = 0))) THEN
  577.             valid := FALSE;
  578.           END
  579.         END
  580.       END;
  581.     END;
  582.   END TextToDate;
  583.  
  584. END TimeConvert.
  585.